	PROGRAM	LASERTONE
C  7-Jul-94 fixed map-area selection bug.

	INCLUDE 'lasertonecommon.f'

	LOGICAL		EXISTS
	CHARACTER	IODEV*16
	INTEGER*4	NOPTIONS
	  PARAMETER	(NOPTIONS=15)
	CHARACTER	OPTLIST(NOPTIONS)*32/
	1		'*',
	1		'FIRSTSECTION',
	1               'HEIGHT',
	1		'INTERPOLATE',
	1		'LANDSCAPE',
	1		'LOWER',
	1		'NOHEADER',
	1		'NSECTIONS',
	1		'OUTPUTFILE',
	1               'RLE',
	1		'REVERSE',
	1		'UPPER',
	1		'XORIGIN',
	1		'YORIGIN',
	1		'WIDTH'/

	LOGICAL		OPT_PRESENT

C  get the source spec
	IF (.NOT.OPT_PRESENT(OPTLIST,NOPTIONS,'*',PARAM)) THEN
	  CALL ERROR('Missing source file parameter')
	ELSE
	  SOURCEFILE=PARAM(1:LNBLNK(PARAM))
	END IF


C  -landscape
	LANDSCAPE=OPT_PRESENT(OPTLIST,NOPTIONS,'LANDSCAPE',PARAM)


C  -outputfile=
	OUTPUTFILE=' '
	IF (OPT_PRESENT(OPTLIST,NOPTIONS,'OUTPUTFILE',PARAM))
	1  OUTPUTFILE=PARAM(1:LNBLNK(PARAM))

C  -firstsection=
	FIRSTSECTION=-1
	IF (OPT_PRESENT(OPTLIST,NOPTIONS,'FIRSTSECTION',PARAM)) THEN
	  READ(PARAM,FMT=*,IOSTAT=IOERR) FIRSTSECTION
	  IF (IOERR.NE.0.OR.FIRSTSECTION.LT.0)
	1 STOP 'Illegal firstsection= parameter'
	END IF

C  -height=
	HEIGHT=-1.0
	IF (OPT_PRESENT(OPTLIST,NOPTIONS,'HEIGHT',PARAM)) THEN
	  READ(PARAM,FMT=*,IOSTAT=IOERR) HEIGHT
	  IF (IOERR.NE.0.OR.HEIGHT.LE.0) STOP 'Illegal height= parameter'
	END IF

C  -interpolate
	INTERPOLATE=0
	IF (OPT_PRESENT(OPTLIST,NOPTIONS,'INTERPOLATE',PARAM)) THEN
	  READ(PARAM,FMT=*,IOSTAT=IOERR) INTERPOLATE
	  IF (IOERR.NE.0.OR.INTERPOLATE.LT.0)
	1 STOP 'Illegal interpolate= parameter'
	END IF

C  -lower=
	LOWER = .FALSE.
	IF (OPT_PRESENT(OPTLIST,NOPTIONS,'LOWER',PARAM)) THEN
	  LOWER = .TRUE.
	  READ(PARAM,FMT=*,IOSTAT=IOERR) DLOWER
	  IF (IOERR.NE.0) STOP 'Illegal lower= parameter'
	END IF

C  -noheader
	HEADER_REQD=.NOT.OPT_PRESENT(OPTLIST,NOPTIONS,'NOHEADER',PARAM)

C  -nsections=
	NSECTIONS=-1
	IF (OPT_PRESENT(OPTLIST,NOPTIONS,'NSECTIONS',PARAM)) THEN
	  READ(PARAM,FMT=*,IOSTAT=IOERR) NSECTIONS
	  IF (IOERR.NE.0.OR.NSECTIONS.LE.0)
	1 STOP 'Illegal nsections= parameter'
	END IF

C  -rle
	RLE=OPT_PRESENT(OPTLIST,NOPTIONS,'RLE',PARAM)
	
C  -reverse
	REVERSE=OPT_PRESENT(OPTLIST,NOPTIONS,'REVERSE',PARAM)

C  -upper=
	UPPER=.FALSE.
	IF (OPT_PRESENT(OPTLIST,NOPTIONS,'UPPER',PARAM)) THEN
	  UPPER=.TRUE.
	  READ(PARAM,FMT=*,IOSTAT=IOERR) DUPPER
	  IF (IOERR.NE.0.OR.DUPPER.LE.0)
	1 STOP 'Illegal upper= parameter'
	END IF

C  -width=
	WIDTH=-1.0
	IF (OPT_PRESENT(OPTLIST,NOPTIONS,'WIDTH',PARAM)) THEN
	  READ(PARAM,FMT=*,IOSTAT=IOERR) WIDTH
	  IF (IOERR.NE.0.OR.WIDTH.LE.0) STOP 'Illegal width= parameter'
	END IF

C  -xorigin=
	XORIGIN=10
	IF (OPT_PRESENT(OPTLIST,NOPTIONS,'XORIGIN',PARAM)) THEN
	  READ(PARAM,FMT=*,IOSTAT=IOERR) XORIGIN
	  IF (IOERR.NE.0) STOP 'Illegal xorigin= parameter'
	END IF

C  -yorigin=
	YORIGIN=-1
	IF (OPT_PRESENT(OPTLIST,NOPTIONS,'YORIGIN',PARAM)) THEN
	  READ(PARAM,FMT=*,IOSTAT=IOERR) YORIGIN
	  IF (IOERR.NE.0) STOP 'Illegal yorigin= parameter'
	END IF

C  having checked all switches and parameters, proceed.
	CALL  LASERTONE_IT
	END

C**************************************************************************
	SUBROUTINE LASERTONE_IT
	INCLUDE 'lasertonecommon.f'

	INTEGER		ARGNUMBER
	CHARACTER	ARGUMENT*64
	REAL		CELL(6)
	INTEGER*4	CHARHT
	INTEGER		CLENGTH
	INTEGER		CLINE
	CHARACTER	COMMAND_LINE*128
	REAL		COLSTEP
	REAL		CSTEP
	REAL		D
	REAL		DL
	REAL		DMAX
	REAL            DMEAN
	REAL            DMIN
	REAL		DR
	LOGICAL		EXISTS
	INTEGER		I
	INTEGER		IC
	INTEGER		ICLINE
	INTEGER		ICHARS	
	INTEGER		ILABEL
	INTEGER		IMAGEIN
	REAL		IMAGELINE(1:4096,2)
	INTEGER		IMAGEROW
	INTEGER		IMAGEXEND
	INTEGER		IMAGEXLEN
	INTEGER		IMAGEXSTART
	INTEGER		IMAGEYEND
	INTEGER		IMAGEYLEN
	INTEGER		IMAGEYSTART
	INTEGER		IMAGEZEND
	INTEGER		IMAGEZPOSN
	INTEGER		IMAGEZSTART
	INTEGER		INEW
	INTEGER		IPREV
	INTEGER		IPTR
	INTEGER		IR
	INTEGER         IXYZMAX(3)
	INTEGER         IXYZMIN(3)
	INTEGER		J
	BYTE		LABELS(80,10)
	INTEGER		MODE
	INTEGER		MXYZ(3)
	INTEGER		NXYZ(3)
	INTEGER		NLABELS
	INTEGER		ORIENTATION
	INTEGER		PSPTR
	BYTE		PS_LINE(4096)
	CHARACTER	PS_STRING*256
	REAL		ROWSTEP
	REAL		RSTEP
	INTEGER		RUN_LENGTH_ENCODE
	CHARACTER	TEMPSTR*32
	INTEGER*4	TEXTX
	INTEGER*4	TEXTY
	INTEGER		TONEIN
	INTEGER		TONEOUT

	TONEIN=9
	INQUIRE(FILE=SOURCEFILE,EXIST=EXISTS)
	IF (.NOT.EXISTS) CALL ERROR('Cant open tone input file')
	  

	IF (OUTPUTFILE.EQ.' ') OUTPUTFILE='tone.ps'
C  default to unit 6 for output file, so we can make use of pipes
	TONEOUT=1
	OPEN(UNIT=TONEOUT,FILE=OUTPUTFILE,STATUS='UNKNOWN',IOSTAT=IOERR)
	IF (IOERR.NE.0) CALL ERROR('Cant open tone output file')

C*** get command line
	ARGNUMBER = 0
	ICLINE = 1
	COMMAND_LINE=' '
  800   CALL  GETARG(ARGNUMBER,ARGUMENT)
	IF (ARGUMENT.EQ.' ') GO TO 900
	ICHARS = LNBLNK(ARGUMENT)
	COMMAND_LINE(ICLINE:ICLINE+ICHARS) = ARGUMENT(1:ICHARS)
	ICLINE = ICLINE + ICHARS + 2
	ARGNUMBER = ARGNUMBER + 1
	GO TO 800
  900	CHARHT=3

C*** read image file header
	IMAGEIN=TONEIN
  	CALL IMOPEN(IMAGEIN,SOURCEFILE,'RO')		!open image file
	CALL IRDHDR(IMAGEIN,NXYZ,MXYZ,MODE,DMIN,DMAX,DMEAN) !read image header
	CALL IRTCEL(IMAGEIN,CELL)			!extract CELL parameters
	CALL ICLLIM(IMAGEIN,IXYZMIN,IXYZMAX,NXYZ)	!extract area limits
	CALL IRTLAB(IMAGEIN,LABELS,NLABELS)		!extract labels
	IMAGEXSTART=IXYZMIN(1)				!image X range
	IMAGEXEND=IXYZMAX(1)
	IMAGEYSTART=IXYZMIN(2)				!image Y range
	IMAGEYEND=IXYZMAX(2)
	IMAGEZSTART=IXYZMIN(3)				!image Z range
	IMAGEZEND=IXYZMAX(3)
	IMAGEXLEN=IMAGEXEND-IMAGEXSTART+1
	IMAGEYLEN=IMAGEYEND-IMAGEYSTART+1
	IF (.NOT.LOWER) DLOWER=DMIN
	IF (.NOT.UPPER) DUPPER=DMAX
	DRANGE=ABS(DUPPER-DLOWER)			!density range

	IF (FIRSTSECTION.GE.0) THEN
	  IF (FIRSTSECTION.LT.IMAGEZSTART)
	1 STOP 'Requested firstsection < image firstsection'
	  IF (FIRSTSECTION.GT.IMAGEZEND)
	1 STOP 'Requested firstsection > image lastsection'
	ELSE
	  FIRSTSECTION=IMAGEZSTART
	END IF

	IF (NSECTIONS.GT.0) THEN
	  IF (FIRSTSECTION+NSECTIONS-1.GT.IMAGEZEND) THEN
	    WRITE(6,FMT='(1X,A)')
	1   'Too many sections requested. Nsections truncated'
	    NSECTIONS=IMAGEZEND-FIRSTSECTION+1
	  END IF
	ELSE
	  NSECTIONS=IMAGEZEND-FIRSTSECTION+1
	END IF
	  

C  adjust width/height as necessary
	IF (WIDTH.LT.0.AND.HEIGHT.LT.0) THEN
C  set the longest side to the default, and scale the other to suit
	  IF (IMAGEXLEN.GT.IMAGEYLEN) THEN
	    WIDTH=190.0
	  ELSE
	    HEIGHT=190.0
	  END IF
	END IF
	IF (WIDTH.LT.0.AND.HEIGHT.GT.0) THEN
C  adjust width based on height
	  WIDTH=(IMAGEXLEN*HEIGHT)/IMAGEYLEN
	ELSE IF (HEIGHT.LT.0.AND.WIDTH.GT.0) THEN
C  adjust height based on width
	  HEIGHT=(IMAGEYLEN*WIDTH)/IMAGEXLEN
	END IF	
C  invent yorigin if it wasnt specified
	IF (YORIGIN.LT.0) THEN
	  IF (.NOT.LANDSCAPE)  YORIGIN=270-(HEIGHT+NLABELS*4)
	  IF (LANDSCAPE)  YORIGIN=180-(HEIGHT+NLABELS*4)
	END IF

	RUN_LENGTH_ENCODE=0
	IF (RLE) RUN_LENGTH_ENCODE=1
	ORIENTATION=0
	IF (LANDSCAPE) ORIENTATION=1


C  For all sections:
	DO IMAGEZPOSN=FIRSTSECTION,FIRSTSECTION+NSECTIONS-1,1

	CALL PSCRIPT_INIT(
	1 TONEOUT,
	1 0,ORIENTATION,
	1 XORIGIN,YORIGIN,WIDTH,HEIGHT,
	1 RUN_LENGTH_ENCODE,
	1 IMAGEXLEN*(INTERPOLATE+1),
	1 IMAGEYLEN*(INTERPOLATE+1))
	TEXTX=10
	TEXTY=290
	IF (LANDSCAPE) TEXTY=200
	IPTR=0
	CALL MOVESTRING('/Helvetica findfont ',PS_STRING,IPTR)
	CALL IFORMAT(CHARHT,PS_STRING,IPTR)
	CALL MOVESTRING(' scalefont setfont',PS_STRING,IPTR)
	CALL PSCRIPT_COPY(PS_STRING(1:IPTR))

C  write header if required
	IF (HEADER_REQD) THEN
	  IF (IMAGEZPOSN.EQ.FIRSTSECTION)
	1 WRITE(6,FMT='(1X,A)') COMMAND_LINE(1:ICLINE-2)
	  TEXTY=TEXTY-CHARHT-1
	  CALL TONE_TEXT(TEXTX,TEXTY,COMMAND_LINE(1:ICLINE-2))
	  DO I=1,NLABELS
	    IF (IMAGEZPOSN.EQ.FIRSTSECTION)
	1   WRITE(6,FMT='(1X,80A1)') (LABELS(J,I),J=1,80)
	    WRITE(PS_STRING,FMT='(80A1)') (LABELS(J,I),J=1,80)
	    TEXTY=TEXTY-CHARHT-1
	    CALL TONE_TEXT(TEXTX,TEXTY,PS_STRING(1:LNBLNK(PS_STRING)))
	  END DO
	  IPTR=0
	  CALL MOVESTRING('Section number=',PS_STRING,IPTR)
	  CALL IFORMAT(IMAGEZPOSN,PS_STRING,IPTR)
	  CALL MOVESTRING(' Density range: DMIN=',PS_STRING,IPTR)
	  WRITE(TEMPSTR,FMT='(E10.2)') DMIN
	  CALL MOVESTRING(TEMPSTR(1:LNBLNK(TEMPSTR))//' DMAX=',PS_STRING,IPTR)
	  WRITE(TEMPSTR,FMT='(E10.2)') DMAX
	  CALL MOVESTRING(TEMPSTR(1:LNBLNK(TEMPSTR)),PS_STRING,IPTR)
	  IF (IMAGEZPOSN.EQ.FIRSTSECTION)
	1 WRITE(6,FMT='(1X,A)') PS_STRING(1:IPTR)
	  TEXTY=TEXTY-CHARHT-1
	  CALL TONE_TEXT(TEXTX,TEXTY,PS_STRING(1:IPTR))
	  IPTR=0
	  CALL MOVESTRING('Image X/Y limits: XMIN=',PS_STRING,IPTR)
	  CALL IFORMAT(IXYZMIN(1),PS_STRING,IPTR)
	  CALL MOVESTRING(' XMAX=',PS_STRING,IPTR)
	  CALL IFORMAT(IXYZMAX(1),PS_STRING,IPTR)
	  CALL MOVESTRING(' YMIN=',PS_STRING,IPTR)
	  CALL IFORMAT(IXYZMIN(2),PS_STRING,IPTR)
	  CALL MOVESTRING(' YMAX=',PS_STRING,IPTR)
	  CALL IFORMAT(IXYZMAX(2),PS_STRING,IPTR)
	  IF (IMAGEZPOSN.EQ.FIRSTSECTION)
	1 WRITE(6,FMT='(1X,A)') PS_STRING(1:IPTR)
	  TEXTY=TEXTY-CHARHT-1
	  CALL TONE_TEXT(TEXTX,TEXTY,PS_STRING(1:IPTR))
	END IF

C  tone image.
	INEW=1
	IPREV=2
C  read 1st line ready for any interpolation. read image backwards.
C  image rows are numbered from 0 upwards
ccc	CALL IMPOSN(IMAGEIN,IMAGEZPOSN,IMAGEYLEN-1)
	CALL IMPOSN(IMAGEIN,IMAGEZPOSN,IMAGEYEND-1)
	CALL IRDPAL(IMAGEIN,IMAGELINE(1,INEW),IMAGEXSTART,IMAGEXEND)
C  allow for interpolation of last point
	IMAGELINE(IMAGEXLEN+1,INEW)=IMAGELINE(IMAGEXLEN,INEW)
	COLSTEP=1.0/(INTERPOLATE+1)
	ROWSTEP=COLSTEP
	
	DO IMAGEROW=IMAGEYEND,IMAGEYSTART,-1
C  read next row (of a pair if interpolating) of image densities
C  unless we are at the map end, in which case force the new row to
C  be the same as the prev row
	  I=IPREV
	  IPREV=INEW
	  INEW=I
	  IF (IMAGEROW.EQ.1) THEN
	    DO I=1,IMAGEXLEN+1
	      IMAGELINE(I,INEW)=IMAGELINE(I,IPREV)
	    END DO
	  ELSE
	    CALL IMPOSN(IMAGEIN,IMAGEZPOSN,IMAGEROW-2)
	    CALL IRDPAL(IMAGEIN,IMAGELINE(1,INEW),IMAGEXSTART,IMAGEXEND)
C  allow for interpolation of last point
	    IMAGELINE(IMAGEXLEN+1,INEW)=IMAGELINE(IMAGEXLEN,INEW)
	  END IF
	  RSTEP=0.0
	  DO IR=1,INTERPOLATE+1
	    PSPTR=0
	    DO I=1,IMAGEXLEN
	      CSTEP=0.0
	      DL=IMAGELINE(I,IPREV)+
	1     (IMAGELINE(I,INEW)-IMAGELINE(I,IPREV))*RSTEP
	      DR=IMAGELINE(I+1,IPREV)+
	1     (IMAGELINE(I+1,INEW)-IMAGELINE(I+1,IPREV))*RSTEP
	      DO IC=1,INTERPOLATE+1
	        D=DL+(DR-DL)*CSTEP
	        IF (D.LT.DLOWER) D=DLOWER
	        IF (D.GT.DUPPER) D=DUPPER
	        D=D-DLOWER
	        J=(D/DRANGE)*255
	        IF (J.GT.255) J=255
	        IF (.NOT.REVERSE) J=255-J			!invert video
	        IF (J.GT.127) J=J-256
	        PSPTR=PSPTR+1
	        PS_LINE(PSPTR)=J
	        CSTEP=CSTEP+COLSTEP
	      END DO
	    END DO
	    CALL PSCRIPT_GREYIMAGE(PS_LINE)
	    RSTEP=RSTEP+ROWSTEP
	  END DO
	END DO

	CALL PSCRIPT_ENDIMAGE

C  put a box round the image
	IPTR=0
	CALL FFORMAT(XORIGIN,PS_STRING,IPTR)
	CALL MOVESTRING(' ',PS_STRING,IPTR)
	CALL FFORMAT(YORIGIN,PS_STRING,IPTR)
	CALL MOVESTRING(' moveto ',PS_STRING,IPTR)	
	CALL FFORMAT(XORIGIN,PS_STRING,IPTR)
	CALL MOVESTRING(' ',PS_STRING,IPTR)
	CALL FFORMAT(YORIGIN+HEIGHT,PS_STRING,IPTR)
	CALL MOVESTRING(' lineto ',PS_STRING,IPTR)	
	CALL FFORMAT(XORIGIN+WIDTH,PS_STRING,IPTR)
	CALL MOVESTRING(' ',PS_STRING,IPTR)
	CALL FFORMAT(YORIGIN+HEIGHT,PS_STRING,IPTR)
	CALL MOVESTRING(' lineto ',PS_STRING,IPTR)	
	CALL FFORMAT(XORIGIN+WIDTH,PS_STRING,IPTR)
	CALL MOVESTRING(' ',PS_STRING,IPTR)
	CALL FFORMAT(YORIGIN,PS_STRING,IPTR)
	CALL MOVESTRING(' lineto ',PS_STRING,IPTR)	
	CALL FFORMAT(XORIGIN,PS_STRING,IPTR)
	CALL MOVESTRING(' ',PS_STRING,IPTR)
	CALL FFORMAT(YORIGIN,PS_STRING,IPTR)
	CALL MOVESTRING(' lineto stroke',PS_STRING,IPTR)	
	CALL PSCRIPT_COPY(PS_STRING(1:IPTR))
	CALL PSCRIPT_END
	TYPE *,'Section ',IMAGEZPOSN,' done'

C  Next section:
	END DO

999	CALL EXIT(0)
	END

C***************************************************************************
	FUNCTION NDIGITS(NUMBER)
	IF (NUMBER.EQ.0) THEN
	  NDIGITS=1
	  RETURN
	END IF
	NDIGITS=LOG10(FLOAT(IABS(NUMBER))+0.01)+1
	RETURN
	END

C***************************************************************************
	LOGICAL FUNCTION OPT_PRESENT(
	1 OPLIST,OPLISTLEN,OPT,PARAM)
C  options are introduced with a - sign
C  enough of the option name has to be typed to uniquely
C  identify it. If a parameter is required, it must follow
C  the option with a separating = sign
C  If spaces or tabs are part of a parameter, either the spaces/tabs
C  must be indvidually escaped with a \ char, or the whole parameter
C  must be enclosed in ".
C  If " is part of a parameter, it must be escaped with \

	IMPLICIT NONE
	INTEGER*4	ARGLEN
	INTEGER*4	ARGNUMBER
	CHARACTER	ARGUMENT*132
	CHARACTER	ARGOP*132
	INTEGER*4	ARGOPLEN
	INTEGER		I
	INTEGER*4	IOP
	INTEGER*4	KOP
	INTEGER*4	LNBLNK
	INTEGER*4	NMATCHES
	CHARACTER	PARAM*(*)
	INTEGER*4	OPLISTLEN
	CHARACTER	OPT*(*)
	CHARACTER	OPLIST(OPLISTLEN)*(*)
	INTEGER*4	OPLEN

	OPT_PRESENT=.FALSE.
	PARAM=' '
C  make sure OPT is present in OPLIST. Fatal error if not.
	OPLEN=LEN(OPT)
	DO I=1,OPLISTLEN
	  IF (OPT(1:OPLEN).EQ.OPLIST(I)(1:LNBLNK(OPLIST(I)))) GOTO 10
	END DO
	TYPE *,'SUBROUTINE::OPT_PRESENT: OPT not in OPT list ',OPT
	STOP
10	ARGNUMBER=0
11	ARGNUMBER=ARGNUMBER+1
	CALL GETARG(ARGNUMBER,ARGUMENT)
	IF (ARGUMENT.EQ.' ') RETURN
	ARGLEN=LNBLNK(ARGUMENT)
C  is it a OPT?
	IF (ARGUMENT(1:1).EQ.'-') THEN
	  ARGOP=ARGUMENT(2:ARGLEN)
	  ARGOPLEN=ARGLEN-1
	  I=INDEX(ARGUMENT(1:ARGLEN),'=')
	  IF (I.NE.0) THEN
C** FIX UP FOR LONE = 
C  there is a parameter.
	    PARAM=ARGUMENT(I+1:ARGLEN)
	    ARGOP=ARGUMENT(2:I-1)
	    ARGOPLEN=I-2
	  END IF
	ELSE
	  PARAM=ARGUMENT(1:ARGLEN)
	  IF (OPT(1:OPLEN).EQ.'*') THEN
	    OPT_PRESENT=.TRUE.
	  END IF
	  RETURN
	END IF
C  force case-blind
	DO I=1,ARGOPLEN
	  IF (ARGOP(I:I).GE.'a'.AND.ARGOP(I:I).LE.'z')
	1 ARGOP(I:I)=CHAR(ICHAR(ARGOP(I:I))-
     *    (ICHAR('a')-ICHAR('A')))
C***	1 ARGOP(I:I)=CHAR(ICHAR(ARGOP(I:I)).AND.'137'O)
	END DO
C  search OPT list for unambiguous entry.
	NMATCHES=0
	KOP=0
	DO IOP=1,OPLISTLEN
	  IF (ARGOPLEN.LE.LNBLNK(OPLIST(IOP))) THEN
C  this is a candidate
	    IF (ARGOP(1:ARGOPLEN).EQ.OPLIST(IOP)(1:ARGOPLEN)) THEN	!got a match
	      NMATCHES=NMATCHES+1
	      KOP=IOP
	    END IF
	  END IF
	END DO
	IF (NMATCHES.EQ.0) THEN
	  TYPE *,'Illegal option ',ARGOP(1:ARGOPLEN)
	  STOP
	END IF
C  was it unique?
	IF (NMATCHES.NE.1) THEN
C  no
	  TYPE *,'Ambiguous option ',ARGOP(1:ARGOPLEN)
	  STOP
	END IF
C  yes.
C  does it match OPT
	IF (ARGOPLEN.GT.OPLEN) GOTO 11
	IF (ARGOP(1:ARGOPLEN).NE.OPT(1:ARGOPLEN)) GOTO 11
	OPT_PRESENT=.TRUE.
	RETURN
	END

C***************************************************************************
	SUBROUTINE UPPERCASE(SOURCE,DEST)
	CHARACTER	SOURCE*(*)
	CHARACTER	DEST*(*)
	DO I=1,MIN(LEN(SOURCE),LEN(DEST))
	  DEST(I:I)=SOURCE(I:I)
	  IF (SOURCE(I:I).GE.'a'.AND.SOURCE(I:I).LE.'z')
	1 DEST(I:I)=CHAR(ICHAR(SOURCE(I:I)).AND.'137'O)
	END DO
	RETURN
	END

C***************************************************************************
	SUBROUTINE ERROR(STRING)
	INCLUDE		'lasertonecommon.f'
	CHARACTER	STRING*(*)
	WRITE(6,FMT='(1X,A)') STRING
	CALL EXIT(0)
	END

C****************************************************************************
	SUBROUTINE TONE_TEXT(IX,IY,STRING)
	INTEGER*4		IX
	INTEGER*4		IY
	CHARACTER		STRING*(*)
	CHARACTER		PS_STRING*256
	
	IPTR=0
	I=LEN(STRING)
	CALL IFORMAT(IX,PS_STRING,IPTR)
	CALL MOVESTRING(' ',PS_STRING,IPTR)
	CALL IFORMAT(IY,PS_STRING,IPTR)
	CALL MOVESTRING(' moveto (',PS_STRING,IPTR)
	CALL MOVESTRING(STRING,PS_STRING,IPTR)
	CALL MOVESTRING(') show',PS_STRING,IPTR)
	CALL PSCRIPT_COPY(PS_STRING(1:IPTR))
	RETURN
	END

C****************************************************************************
	SUBROUTINE MOVESTRING(SOURCE,DEST,IPTR)
	CHARACTER	SOURCE*(*)
	CHARACTER	DEST*(*)
	DO I=1,LEN(SOURCE)
	  IPTR=IPTR+1
	  DEST(IPTR:IPTR)=SOURCE(I:I)
	END DO
	RETURN
	END

C****************************************************************************
	SUBROUTINE IFORMAT(I,DESTSTR,IPTR)
	CHARACTER	DESTSTR*(*)
	CHARACTER	TEMPSTR*16

	WRITE(TEMPSTR,FMT=*) I
	J=1
	DO WHILE (TEMPSTR(J:J).EQ.' ')
	  J=J+1
	END DO
	DO K=J,LNBLNK(TEMPSTR)
	  IPTR=IPTR+1
	  DESTSTR(IPTR:IPTR)=TEMPSTR(K:K)
	END DO
	RETURN
	END

C****************************************************************************
	SUBROUTINE FFORMAT(F,DESTSTR,IPTR)
	CHARACTER	DESTSTR*(*)
	CHARACTER	TEMPSTR*16

	WRITE(TEMPSTR,FMT=*) F
	J=1
	DO WHILE (TEMPSTR(J:J).EQ.' ')
	  J=J+1
	END DO
	DO K=J,LNBLNK(TEMPSTR)
	  IPTR=IPTR+1
	  DESTSTR(IPTR:IPTR)=TEMPSTR(K:K)
	END DO
	RETURN
	END

C*****************************************************************************
	INTEGER FUNCTION LNBLNK(STRING)
	CHARACTER	STRING*(*)
C  search forward for the 1st terminating zero,
C  then backwards for the 1st non-space
	DO I=1,LEN(STRING)
	  IF (STRING(I:I).EQ.CHAR(0)) GOTO 5
	END DO
5	I=I-1
	DO J=I,1,-1
	  IF (STRING(J:J).NE.' ') GOTO 10
	END DO
	J=0
10	LNBLNK=J
	RETURN
	END
